Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / exampl_4 / frmmain.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1999-08-16 | 19.0 KB | 618 lines

VERSION 5.00 Begin VB.Form frmMain Appearance = 0 'Flat AutoRedraw = -1 'True BackColor = &H80000000& BorderStyle = 1 'Fixed Single Caption = "BitBlt...and more. . . . ." ClientHeight = 6705 ClientLeft = 1080 ClientTop = 1755 ClientWidth = 7905 ForeColor = &H80000008& HelpContextID = 10 Icon = "frmmain.frx":0000 KeyPreview = -1 'True LinkTopic = "Form1" MaxButton = 0 'False PaletteMode = 1 'UseZOrder ScaleHeight = 6705 ScaleWidth = 7905 StartUpPosition = 2 'CenterScreen Begin VB.Timer tmrMain Interval = 1 Left = 1680 Top = 480 End Begin VB.CommandButton cmdExit Caption = "&Exit" Height = 375 Left = 120 TabIndex = 1 ToolTipText = "Quit" Top = 1080 WhatsThisHelpID = 10 Width = 1215 End Begin VB.PictureBox picSrc00 Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H80000005& BorderStyle = 0 'None BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 480 HelpContextID = 270 Left = 240 Picture = "frmmain.frx":0442 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 0 ToolTipText = "Bitmaps" Top = 360 WhatsThisHelpID = 270 Width = 480 End Begin VB.PictureBox picDEST Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H80000005& BorderStyle = 0 'None BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 6135 HelpContextID = 280 Left = 1560 Picture = "frmmain.frx":1084 ScaleHeight = 6135 ScaleWidth = 6150 TabIndex = 2 Top = 360 WhatsThisHelpID = 280 Width = 6150 Begin VB.Timer tmrBORDER Interval = 1 Left = 120 Top = 2520 End Begin VB.Timer tmrOFFMUSIC Interval = 1 Left = 120 Top = 2040 End Begin VB.Timer tmrONMUSIC Interval = 1 Left = 120 Top = 1560 End Begin VB.Timer tmrPOS Interval = 1 Left = 120 Top = 1080 End Begin VB.Timer tmrSND Interval = 1 Left = 120 Top = 600 End End Begin VB.Frame Frame4 BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 6495 HelpContextID = 340 Left = 1440 TabIndex = 3 Top = 120 WhatsThisHelpID = 340 Width = 6375 End Begin VB.Frame Frame6 Caption = "Sprites" Height = 855 HelpContextID = 350 Left = 120 TabIndex = 4 Top = 120 WhatsThisHelpID = 350 Width = 1215 Begin VB.PictureBox picSrc01 Appearance = 0 'Flat AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H80000005& BorderStyle = 0 'None BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 480 HelpContextID = 360 Left = 600 Picture = "frmmain.frx":7C116 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 5 ToolTipText = "Bitmaps" Top = 240 WhatsThisHelpID = 360 Width = 480 End End Begin VB.Label Label4 Caption = "dosascii@hotmail.com" BeginProperty Font Name = "Small Fonts" Size = 6 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 13 Top = 6360 Width = 1215 End Begin VB.Line Line8 BorderColor = &H80000005& X1 = 120 X2 = 1320 Y1 = 3000 Y2 = 3000 End Begin VB.Line Line7 BorderColor = &H80000003& BorderStyle = 6 'Inside Solid BorderWidth = 2 X1 = 120 X2 = 1320 Y1 = 3000 Y2 = 3000 End Begin VB.Label lblMUSIC Caption = "MUSIC: Off" Height = 255 Left = 120 TabIndex = 12 ToolTipText = "Toggle Music" Top = 2760 WhatsThisHelpID = 430 Width = 1095 End Begin VB.Label lblSFX Caption = "SFX: Off" Height = 255 Left = 120 TabIndex = 11 ToolTipText = "Toggle Sound Effects" Top = 2520 WhatsThisHelpID = 440 Width = 1095 End Begin VB.Label Label1 Alignment = 2 'Center Caption = "Options:" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = -1 'True Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 120 TabIndex = 10 Top = 2280 WhatsThisHelpID = 450 Width = 1095 End Begin VB.Line Line6 BorderColor = &H80000005& X1 = 120 X2 = 1320 Y1 = 2160 Y2 = 2160 End Begin VB.Line Line5 BorderColor = &H80000003& BorderStyle = 6 'Inside Solid BorderWidth = 2 X1 = 120 X2 = 1320 Y1 = 2160 Y2 = 2160 End Begin VB.Line Line4 BorderColor = &H80000005& X1 = 120 X2 = 1320 Y1 = 1560 Y2 = 1560 End Begin VB.Line Line3 BorderColor = &H80000003& BorderStyle = 6 'Inside Solid BorderWidth = 2 X1 = 120 X2 = 1320 Y1 = 1560 Y2 = 1560 End Begin VB.Label lblYPos Caption = "POS" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 360 TabIndex = 9 Top = 1920 WhatsThisHelpID = 500 Width = 855 End Begin VB.Label lblXPos Caption = "POS" BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 255 Left = 360 TabIndex = 8 Top = 1680 WhatsThisHelpID = 510 Width = 855 End Begin VB.Label Label3 Caption = "Y:" Height = 255 Left = 120 TabIndex = 7 Top = 1920 WhatsThisHelpID = 520 Width = 255 End Begin VB.Label Label2 Caption = "X:" Height = 255 Left = 120 TabIndex = 6 Top = 1680 WhatsThisHelpID = 530 Width = 255 End Begin VB.Line Line2 BorderColor = &H80000005& X1 = 0 X2 = 7920 Y1 = 15 Y2 = 15 End Begin VB.Line Line1 BorderColor = &H80000003& BorderStyle = 6 'Inside Solid BorderWidth = 2 X1 = 0 X2 = 7920 Y1 = 0 Y2 = 0 End Begin VB.Menu file Caption = "&File" Begin VB.Menu exit Caption = "&Exit" End End Begin VB.Menu options Caption = "&Options" Begin VB.Menu sfx Caption = "&Sound FX" Checked = -1 'True End Begin VB.Menu mus Caption = "&Music" Checked = -1 'True End End Begin VB.Menu help Caption = "&Help" Begin VB.Menu about Caption = "&About..." Begin VB.Menu abz Caption = "&This program..." End End End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit '====================== ' Sprite Information '====================== 'For BitBlt. Dim XStart As Integer 'Starting X position of the sight Dim YStart As Integer 'Starting Y position of the sight Dim SightInc As Integer 'How many pixels to move the sight Dim NewXPos As Integer 'New X position of the sight Dim NewYPos As Integer 'New Y position of the sight Dim OldXPos As Integer 'Old X position of the sight Dim OldYPos As Integer 'Old Y position of the sight 'For Sound. Dim SndEnable As Boolean 'True if Sound Enabled. Dim MusicEnable As Boolean 'True if Music Enabled. 'Keys Dim UKEY As Boolean 'True if Enabled (Up Cursor) Dim DKEY As Boolean 'True if Enabled (Down Cursor) Dim LKEY As Boolean 'True if Enabled (Left Cursor) Dim RKEY As Boolean 'True if Enabled (Right Cursor) Private Sub abz_Click() 'Load About Form. frmAbout.Show vbModal, Me End Sub Private Sub exit_Click() 'Release resources. Set picSrc00 = Nothing Set picSrc01 = Nothing Set picDEST = Nothing Set frmMain = Nothing 'Close MIDI. Call mciSendString("Close All", 0&, 0, 0) Unload Me 'Shutdown. End Sub Private Sub Form_Load() 'Hide these Labels. lblXPos.Visible = False lblYPos.Visible = False 'Uncheck these values. sfx.Checked = False mus.Checked = False 'Starting Positions. XStart = 184 'Approx middle of the screen, YStart = 184 'to the top left of the sprite. OldXPos = XStart OldYPos = YStart NewXPos = OldXPos NewYPos = OldYPos SightInc = 1 'Number of pixels moved at a time. The smaller the number the smoother.. 'Everything following is BitBlt. ' Paint the Mask onto the Destination using AND operator. Call BitBlt(picDEST.hDC, XStart, YStart, picSrc00.ScaleWidth \ Screen.TwipsPerPixelX, picSrc00.ScaleHeight \ Screen.TwipsPerPixelY, picSrc01.hDC, 0, 0, SRCAND) ' Paint the Source onto the Destination using XOR operator. Call BitBlt(picDEST.hDC, XStart, YStart, picSrc00.ScaleWidth \ Screen.TwipsPerPixelX, picSrc00.ScaleHeight \ Screen.TwipsPerPixelY, picSrc00.hDC, 0, 0, SRCINVERT) ' Update the screen with the updated image in memory. picDEST.Refresh picSrc00.Refresh picSrc01.Refresh End Sub Private Sub cmdExit_Click() 'Release resources. Set picSrc00 = Nothing Set picSrc01 = Nothing Set picDEST = Nothing Set frmMain = Nothing 'Close MIDI. Call mciSendString("Close All", 0&, 0, 0) Unload Me 'Shutdown. End Sub Private Sub Form_KeyDown(KEYCODE As Integer, Shift As Integer) 'Check key pressed, set flag if tracking it. Select Case KEYCODE Case SPACE_BAR giKeyState = giKeyState Or SPACE_BAR_FLAG Case CURSOR_LEFT giKeyState = giKeyState Or CURSOR_LEFT_FLAG Case CURSOR_RIGHT giKeyState = giKeyState Or CURSOR_RIGHT_FLAG Case CURSOR_UP giKeyState = giKeyState Or CURSOR_UP_FLAG Case CURSOR_DOWN giKeyState = giKeyState Or CURSOR_DOWN_FLAG End Select End Sub Private Sub Form_KeyUp(KEYCODE As Integer, Shift As Integer) 'Check key pressed, set flag if tracking it. Select Case KEYCODE Case SPACE_BAR giKeyState = giKeyState And (Not SPACE_BAR_FLAG) Case CURSOR_LEFT giKeyState = giKeyState And (Not CURSOR_LEFT_FLAG) Case CURSOR_RIGHT giKeyState = giKeyState And (Not CURSOR_RIGHT_FLAG) Case CURSOR_UP giKeyState = giKeyState And (Not CURSOR_UP_FLAG) Case CURSOR_DOWN giKeyState = giKeyState And (Not CURSOR_DOWN_FLAG) End Select End Sub Sub Bitmap_Move() 'Everything following is BitBlt. 'Repaint Background(picDEST). 'picDEST is short for Picture Destation. picDEST.Cls '***------*** 'Order of Ops for the call to BitBlt: 'Colour, Colour, Mask 'Colour, Colour, Colour 'AND the mask onto the work area 'Paint the Mask onto the Destination using AND operator. Call BitBlt(picDEST.hDC, NewXPos, NewYPos, picSrc00.ScaleWidth \ Screen.TwipsPerPixelX, picSrc00.ScaleHeight \ Screen.TwipsPerPixelY, picSrc01.hDC, 0, 0, SRCAND) 'Paint the Source onto the Destination using XOR operator. Call BitBlt(picDEST.hDC, NewXPos, NewYPos, picSrc00.ScaleWidth \ Screen.TwipsPerPixelX, picSrc00.ScaleHeight \ Screen.TwipsPerPixelY, picSrc00.hDC, 0, 0, SRCINVERT) OldXPos = NewXPos OldYPos = NewYPos 'Update the screen with the updated image in memory. picDEST.Refresh picSrc00.Refresh picSrc01.Refresh End Sub Private Sub mus_Click() mus.Checked = Not mus.Checked End Sub Private Sub sfx_Click() sfx.Checked = Not sfx.Checked End Sub Private Sub tmrBORDER_Timer() 'Border Dectetion. 'Very primative, please let me know if know a better way 'to do this..... dosascii@hotmail.com If NewXPos <= 0 Then LKEY = False LKEY = True End If If NewXPos >= 377 Then RKEY = False RKEY = True End If If NewYPos <= 0 Then UKEY = False UKEY = True End If If NewYPos >= 377 Then DKEY = False DKEY = True End If End Sub Private Sub tmrMain_Timer() 'This is the main loop 'Checking to see what keys are being pressed... 'Event if key is pressed... '....Move sprite if key pressed. 'If you know how to make the sprite rotate left and right, 'instead of it moving left and right, let me know. 'dosascii@hotmail.com If LKEY = True Then If giKeyState And CURSOR_LEFT_FLAG Then NewXPos = OldXPos - SightInc NewYPos = OldYPos lblXPos.Visible = True lblYPos.Visible = True Bitmap_Move End If End If If RKEY = True Then If giKeyState And CURSOR_RIGHT_FLAG Then NewXPos = OldXPos + SightInc NewYPos = OldYPos lblXPos.Visible = True lblYPos.Visible = True Bitmap_Move End If End If If UKEY = True Then If giKeyState And CURSOR_UP_FLAG Then NewXPos = OldXPos NewYPos = OldYPos - SightInc lblXPos.Visible = True lblYPos.Visible = True 'Play move sound. If SndEnable = True Then sndPlaySound App.Path & "\move.wav", SND_ASYNC Or SND_NODEFAULT End If Bitmap_Move End If End If If DKEY = True Then If giKeyState And CURSOR_DOWN_FLAG Then NewXPos = OldXPos NewYPos = OldYPos + SightInc lblXPos.Visible = True lblYPos.Visible = True 'Play move sound. If SndEnable = True Then sndPlaySound App.Path & "\move.wav", SND_ASYNC Or SND_NODEFAULT End If Bitmap_Move End If End If End Sub Private Sub tmrOFFMUSIC_Timer() 'Music (MIDI) Control. If MusicEnable = False Then Call mciSendString("Close All", 0&, 0, 0) End If End Sub Private Sub tmrONMUSIC_Timer() 'Music (MIDI) Control. If MusicEnable = True Then Call mciSendString("open " + App.Path + "\track01.mid type sequencer alias track01", 0, 0, 0) Call mciSendString("play track01", 0, 0, 0) End If 'If anyone knows how to make this loop/repeat please tell me 'dosascii@hotmail.com End Sub Private Sub tmrPOS_Timer() 'Displaying what pixel the sprite is at. Adding Plus 16 (Cos the 'sprite is 32x32 and the x&y pos is read at the top left of 'the sprite)to the Positions will fake the centre of 'the sprite. lblXPos.Caption = NewXPos + 16 lblYPos.Caption = NewYPos + 16 End Sub Private Sub tmrSND_Timer() 'Checking to see what values have changed in the options. 'Event on values. 'This really isn't necessary If sfx.Checked = True Then lblSFX.Caption = "SFX: On" SndEnable = True lblSFX.Caption = "SFX: Off" SndEnable = False End If If mus.Checked = True Then lblMUSIC.Caption = "MUSIC: On" MusicEnable = True lblMUSIC.Caption = "MUSIC: Off" MusicEnable = False End If End Sub